home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / livdup.arc / DUPER.BAS next >
Encoding:
BASIC Source File  |  1987-12-13  |  5.8 KB  |  149 lines
  1. 10 '   DUPER.BAS version 1.3 -  Copyright (C) 1986,1987 by Clarke Greene K1JX  NOT FOR COMMERCIAL USE
  2. 20 '
  3. 30 '   This Microsoft (tm) BASIC program will build a sorted "Dupe Sheet"
  4. 40 '
  5. 50 '   This file will be produced:
  6. 60 '
  7. 70 '            <filename> - this is a sorted duplicate listing ready for printing
  8. 80 '
  9. 90 '
  10. 100 '   Depending on the version of BASIC for your particular machine, the CLS (Clear Screen) command must
  11. 110 '   be changed.  Consult your own computer's BASIC documentation for more information.
  12. 120 '
  13. 130 '
  14. 140 '   If compiling (a VERY good idea for several orders of magnitude improvement in speed), use O and E switches 
  15. 150 '
  16. 160 '
  17. 170 WARNING$="Copyright (C) 1986,1987 by Clarke Greene K1JX  NOT FOR COMMERCIAL USE"
  18. 171 '
  19. 180 '  Define arrays and variables
  20. 190 DEFINT A-Z : OPTION BASE 1
  21. 200 DIM ENTRY$(2000)
  22. 210 BLANK$=" " : BL$="" : BS$=CHR$(8) : CTRLE$=CHR$(5) : CR$=CHR$(13) : DEL$=BS$+CHR$(32) : ESC$=CHR$(27)
  23. 220 TRUE= -1
  24. 230 DUPE$=CHR$(7)+"   ** Duplicate QSO **"
  25. 240 DUPFORM$="      \         \   \          \   \          \   \          \   \          \"
  26. 250 '
  27. 260 '  Print message to user
  28. 270 CLS
  29. 280 PRINT TAB(26) "Interactive Contest Log Duper"
  30. 290 PRINT : PRINT
  31. 300 PRINT TAB(5) "What is your station's callsign?  ";
  32. 310  INPUT; "", MYCALL$ : IF LEN(MYCALL$)=0 THEN 310 ELSE PRINT : PRINT
  33. 320 '
  34. 330 '  Clear array
  35. 340 FOR I=1 TO 2000
  36. 350  ENTRY$(I)=BL$
  37. 360  NEXT I
  38. 370 '
  39. 380 '  Initialize variables
  40. 390 QSOS=0 : DUPES=0
  41. 400 '
  42. 410 '  Main user entry loop
  43. 420  CLS : PRINT : PRINT
  44. 430  PRINT TAB(5) "Enter callsign {Press Esc to end} >  ";
  45. 440  THISENTRY$=BL$ : CHAR$=BL$
  46. 450  WHILE CHAR$<>CR$ AND CHAR$<>ESC$
  47. 460   CHAR$=INKEY$ : IF LEN(CHAR$)=0 GOTO 530
  48. 470    IF CHAR$=CR$ OR CHAR$=ESC$ GOTO 530                       ' if the character is an <ESC> or <CR>, jump to exit loop
  49. 480    IF CHAR$=BS$ AND LEN(THISENTRY$)>0 THEN THISENTRY$=LEFT$(THISENTRY$,LEN(THISENTRY$)-1) : PRINT DEL$;: GOTO 520
  50. 490    IF ASC(CHAR$)<47 GOTO 530                                 ' ignore invalid characters
  51. 500    IF ASC(CHAR$)>96 THEN GOSUB 1410                          ' capitalize character if necessary
  52. 510   THISENTRY$=THISENTRY$+CHAR$                                ' add character to string
  53. 520   PRINT CHAR$;                                               ' echo character to screen
  54. 530   WEND
  55. 540  IF CHAR$=ESC$ GOTO 810                                      ' if the user wants to quit, jump to close log
  56. 550  IF LEN(THISENTRY$)=0 GOTO 440
  57. 560 '
  58. 570 '  Check for dupes
  59. 580  DUPE.QSO=NOT TRUE : NOTE$=BL$                               ' clear note field
  60. 590  FOR I=1 TO QSOS
  61. 600   IF THISENTRY$=ENTRY$(I) THEN NOTE$=DUPE$ : DUPE.QSO=TRUE : I=QSOS
  62. 610   NEXT I
  63. 620 '
  64. 630 '  Print result of dupe search to screen
  65. 640  PRINT NOTE$ : PRINT
  66. 650  PRINT : PRINT : PRINT : PRINT
  67. 660  PRINT TAB(9) "Total QSOs:";
  68. 670   IF DUPE.QSO THEN PRINT QSOS ELSE PRINT QSOS+1
  69. 680   PRINT
  70. 690  PRINT TAB(9) "Total Duplicates:";
  71. 700   IF DUPE.QSO THEN PRINT DUPES+1 ELSE PRINT DUPES
  72. 710   PRINT : PRINT : PRINT : PRINT : PRINT
  73. 720  PRINT TAB(9) "Type Ctrl-E to change the last entry,"
  74. 730   PRINT TAB(9) "or any other key to continue.  ";
  75. 740   ANS$=INPUT$(1)
  76. 750    IF ANS$=CTRLE$ GOTO 410                                   ' if ^E was input, go back and edit entry
  77. 760 '
  78. 770 '  Adjust variables and loop
  79. 780  IF DUPE.QSO THEN DUPES=DUPES+1 : GOTO 410
  80. 790  QSOS=QSOS+1 : ENTRY$(QSOS)=THISENTRY$ : GOTO 410
  81. 800 '
  82. 810 '  Get filename from user
  83. 820 CLS
  84. 830  PRINT
  85. 840 PRINT TAB(5) "What is the name of the file you want to save the dupe sheet in?"
  86. 850  PRINT : PRINT TAB(8) "> ";
  87. 860  INPUT "", OUTFILE$ : IF LEN(OUTFILE$)=0 THEN 860 ELSE PRINT
  88. 870 '
  89. 880 '  Routine to prevent overwriting existing file
  90. 890 ON ERROR GOTO 1380
  91. 900 OPEN OUTFILE$ FOR INPUT AS #1                                ' try opening file
  92. 910 CLOSE
  93. 920 PRINT CHR$(7) : PRINT TAB(5) "That file already exists - do you want to overwrite it? <Y/N>  ";
  94. 930  ANS$=INPUT$(1) : PRINT
  95. 940  IF ANS$<>"Y" AND ANS$<>"y" THEN 810 ELSE PRINT
  96. 950 ON ERROR GOTO 0
  97. 960 PRINT : PRINT TAB(5) "What frequency band is this dupe sheet for?  ";
  98. 970  INPUT; "", BAND$ : IF LEN(BAND$)=0 THEN 970 ELSE PRINT
  99. 980 '
  100. 990 '  Build dupe sheet
  101. 1000 PRINT : PRINT TAB(5) "Preparing dupe sheet...  ";
  102. 1010 '
  103. 1020 '  Sort callsigns for dupe sheet
  104. 1030 M=QSOS\2
  105. 1040 WHILE M>0
  106. 1050  FOR I=M+1 TO QSOS
  107. 1060   J=I-M
  108. 1070   WHILE J>0
  109. 1080    IF ENTRY$(J)>ENTRY$(J+M) THEN SWAP ENTRY$(J),ENTRY$(J+M) : J=J-M ELSE J=0
  110. 1090   WEND
  111. 1100   NEXT I
  112. 1110  M=M\2
  113. 1120  WEND
  114. 1130 '
  115. 1140 '  Enter dupe sheet into file
  116. 1150 OPEN OUTFILE$ FOR OUTPUT AS #1
  117. 1160  IF QSOS MOD 250=0 THEN LASTPAGE=QSOS\250 ELSE LASTPAGE=QSOS\250+1
  118. 1170 FOR PAGE=1 TO LASTPAGE
  119. 1180  PRINT #1, SPC(20-(LEN(MYCALL$)+LEN(BAND$))/2); MYCALL$; " -- Dupe Sheet for "; BAND$; " MHz Band -- Page"; STR$(PAGE)
  120. 1190  PRINT #1, BL$ : PRINT #1, BL$
  121. 1200  FOR ROW=1 TO 50
  122. 1210   E=(PAGE-1)*250+ROW
  123. 1220   PRINT #1, USING DUPFORM$; ENTRY$(E); ENTRY$(E+50); ENTRY$(E+100); ENTRY$(E+150); ENTRY$(E+200)
  124. 1230   NEXT ROW
  125. 1240  PRINT #1, CHR$(12)                                         ' go to next page
  126. 1250  NEXT PAGE
  127. 1260 CLOSE
  128. 1270 PRINT "done"
  129. 1280 '
  130. 1290 '  Print results
  131. 1300 PRINT : PRINT TAB(8) "Valid QSOs: "; QSOS
  132. 1310 PRINT : PRINT TAB(8) "Duplicate QSOs: "; DUPES
  133. 1320 PRINT : PRINT : PRINT 
  134. 1330 PRINT TAB(5) "Type C to continue with another band for this contest,"
  135. 1340 PRINT : PRINT TAB(5) "or any other key to Exit  ";
  136. 1350 ANS$=INPUT$(1)
  137. 1360  IF ANS$="C" OR ANS$="c" THEN 330 ELSE CLS : SYSTEM
  138. 1370 '
  139. 1380 '  Error trap for existing file
  140. 1390 RESUME 950
  141. 1400 '
  142. 1410 '  Subroutine to capitalize character
  143. 1420 ALPHA=ASC(CHAR$)
  144. 1430 WHILE ALPHA >96
  145. 1440  ALPHA=ALPHA-32
  146. 1450  WEND
  147. 1460 CHAR$=CHR$(ALPHA)
  148. 1470 RETURN
  149.